home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / trace.t < prev    next >
Text File  |  1988-02-05  |  6KB  |  155 lines
  1. (herald trace (env tsys (osys hash)))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; trace
  27.  
  28. (lset *trace-level* 0)
  29.  
  30. (define (comment-indent msg-port n)       ;used also by pp?, and load
  31.   (fresh-line msg-port)
  32.   (writec msg-port #\semicolon)
  33.   (set-hpos msg-port (fx+ n 1)))
  34.  
  35. (define (make-traced-object proc id origin)
  36.   (let ((id (or id (identification proc) proc))
  37.         (active? t)
  38.         (traced-proc nil))
  39.    (set traced-proc
  40.     (join (object (lambda arglist
  41.                     (cond (active?
  42.                            (bind ((active? nil))
  43.                              (let ((port (debug-output)))
  44.                                (comment-indent port *trace-level*)
  45.                                (format port "~d Calling ~s with arguments~_~s~%"
  46.                                        *trace-level* id arglist)))
  47.                            (let ((vals (bind ((*trace-level* (fx+ *trace-level* 1)))
  48.                                           (receive vals 
  49.                                             (if (operation? proc)
  50.                                (apply-traced-operation traced-proc arglist)
  51.                                (apply proc arglist))
  52.                                              vals))))
  53.                                     (bind ((active? nil))
  54.                                       (let ((port (debug-output)))
  55.                                         (comment-indent port *trace-level*)
  56.                                         (format port "~d Returned from ~s with values~_~s~%"
  57.                                                 *trace-level* id vals)))
  58.                                     (apply return vals)))
  59.                           (else
  60.                            (apply proc arglist))))
  61.                   ((get-loaded-file self) (get-loaded-file proc))  ;not a no-op!
  62.                   ((traced-location self) origin)
  63.                   ((traced-id self) id)
  64.                   ((*untrace self) proc)
  65.                   ((traced? self) t)
  66.                   ((print self port)
  67.                    (format port "#{Traced~_~s~_~s}" (object-hash self) proc)))
  68.           proc))
  69.      traced-proc))
  70.  
  71. (define-operation (traced-location obj))
  72. (define-operation (traced-id       obj))
  73. (define-predicate traced?)
  74.  
  75. (define-operation (*trace proc id origin)       ; operations handle
  76.   (make-traced-object proc id origin))
  77.  
  78. (define-operation (*untrace obj))
  79.  
  80. (define *traced-objects* (make-population '*traced-objects*))
  81.  
  82. (define (set-traced loc id)
  83.   (let ((proc (contents loc)))
  84.     (cond ((traced? proc)
  85.            (format (debug-output) "~&~s already traced.~%" id))
  86.           (else
  87.            (let ((traced (*trace (contents loc) id loc)))
  88.              (add-to-population *traced-objects* traced)
  89.              (set (contents loc) traced)
  90.              (format (debug-output) "~&~s traced.~%" id))))
  91.     repl-wont-print))
  92.  
  93. (define (set-untraced loc)
  94.   (let ((proc (contents loc)))
  95.     (cond ((traced? proc)
  96.            (remove-from-population *traced-objects* proc)
  97.            (let ((probe (contents (traced-location proc))))
  98.              (cond ((eq? probe proc)
  99.                     (format (debug-output) "~&~s untraced.~%"
  100.                             (set (contents loc) (*untrace proc))))
  101.                    (else
  102.                     (format (debug-output) "~&~s not untraceable.~%" probe)))))
  103.           (else
  104.            (format (debug-output) "~&~s not traced.~%" proc)))
  105.     repl-wont-print))
  106.  
  107. (define (display-traced-objects)
  108.   (format (debug-output) "~&Traced:~%")
  109.   (walk-population
  110.    *traced-objects*
  111.    (lambda (obj)
  112.      (cond ((eq? obj (contents (traced-location obj)))
  113.             (format (debug-output) "  ~s~%" (traced-id obj))))))
  114.     repl-wont-print)
  115.  
  116. (define (untrace-traced-objects)
  117.   (walk-population
  118.    *traced-objects*
  119.    (lambda (obj)
  120.      (set-untraced (traced-location obj))
  121.      (remove-from-population *traced-objects* obj)))
  122.   repl-wont-print)
  123.  
  124. ;;; "user interface"
  125.  
  126. (define-syntax (trace . places)
  127.   (cond ((null? places)
  128.          '(display-traced-objects))
  129.         (else
  130.          (blockify (map (lambda (place)
  131.                           `(set-traced (,(t-syntax 'locative) ,place)
  132.                                        ',(if (symbol? place) place nil)))
  133.                         places)))))
  134.  
  135. (define-syntax (untrace . places)
  136.   (cond ((null? places)
  137.          '(untrace-traced-objects))
  138.         (else
  139.          (blockify (map (lambda (place)
  140.                           `(set-untraced (,(t-syntax 'locative) ,place)))
  141.                         places)))))  
  142.  
  143. ;;; measure consing performed in evaluating an expression.
  144.  
  145. (define-syntax (pig x)
  146.   `(*pig (lambda () ,x)))
  147.  
  148. (define (*pig x)
  149.   (let ((before (process-global task/area-frontier)))
  150.     (let* ((val (x))
  151.            (amount (fx- (process-global task/area-frontier) before)))
  152.       (format (debug-output) "~&;consed ~s longwords, ~s (#x~x) bytes~%"
  153.               amount (fx* amount 4) (fx* amount 4))
  154.       val)))
  155.